home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / apel / std11-parse.el.z / std11-parse.el
Encoding:
Text File  |  1998-05-21  |  11.3 KB  |  444 lines
  1. ;;; std11-parse.el --- STD 11 parser for GNU Emacs
  2.  
  3. ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;; Keywords: mail, news, RFC 822, STD 11
  7. ;; Version: $Id: std11-parse.el,v 0.18 1997/09/25 16:06:50 morioka Exp $
  8.  
  9. ;; This file is part of MU (Message Utilities).
  10.  
  11. ;; This program is free software; you can redistribute it and/or
  12. ;; modify it under the terms of the GNU General Public License as
  13. ;; published by the Free Software Foundation; either version 2, or (at
  14. ;; your option) any later version.
  15.  
  16. ;; This program is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Code:
  27.  
  28. (require 'std11)
  29. (require 'emu)
  30.  
  31.  
  32. ;;; @ lexical analyze
  33. ;;;
  34.  
  35. (defconst std11-space-chars " \t\n")
  36. (defconst std11-spaces-regexp (` (, (concat "[" std11-space-chars "]+"))))
  37. (defconst std11-special-char-list '(?\] ?\[
  38.                     ?\( ?\) ?< ?> ?@
  39.                     ?, ?\; ?: ?\\ ?\"
  40.                     ?.))
  41. (defconst std11-atom-regexp
  42.   (` (, (concat "^[^" std11-special-char-list std11-space-chars "]+"))))
  43.  
  44. (defun std11-analyze-spaces (string)
  45.   (if (and (string-match std11-spaces-regexp string)
  46.        (= (match-beginning 0) 0))
  47.       (let ((end (match-end 0)))
  48.     (cons (cons 'spaces (substring string 0 end))
  49.           (substring string end)
  50.           ))))
  51.  
  52. (defun std11-analyze-special (str)
  53.   (if (and (> (length str) 0)
  54.        (memq (aref str 0) std11-special-char-list))
  55.       (cons (cons 'specials (substring str 0 1))
  56.         (substring str 1)
  57.         )))
  58.  
  59. (defun std11-analyze-atom (str)
  60.   (if (string-match std11-atom-regexp str)
  61.       (let ((end (match-end 0)))
  62.     (cons (cons 'atom (substring str 0 end))
  63.           (substring str end)
  64.           ))))
  65.  
  66. (defun std11-check-enclosure (str open close &optional recursive from)
  67.   (let ((len (length str))
  68.     (i (or from 0))
  69.     )
  70.     (if (and (> len i)
  71.          (eq (aref str i) open))
  72.     (let (p chr)
  73.       (setq i (1+ i))
  74.       (catch 'tag
  75.         (while (< i len)
  76.           (setq chr (aref str i))
  77.           (cond ((eq chr ?\\)
  78.              (setq i (1+ i))
  79.              (if (>= i len)
  80.              (throw 'tag nil)
  81.                )
  82.              (setq i (1+ i))
  83.              )
  84.             ((eq chr close)
  85.              (throw 'tag (1+ i))
  86.              )
  87.             ((eq chr open)
  88.              (if (and recursive
  89.                   (setq p (std11-check-enclosure
  90.                        str open close recursive i))
  91.                   )
  92.              (setq i p)
  93.                (throw 'tag nil)
  94.                ))
  95.             (t
  96.              (setq i (1+ i))
  97.              ))
  98.           ))))))
  99.  
  100. (defun std11-analyze-quoted-string (str)
  101.   (let ((p (std11-check-enclosure str ?\" ?\")))
  102.     (if p
  103.     (cons (cons 'quoted-string (substring str 1 (1- p)))
  104.           (substring str p))
  105.       )))
  106.  
  107. (defun std11-analyze-domain-literal (str)
  108.   (let ((p (std11-check-enclosure str ?\[ ?\])))
  109.     (if p
  110.     (cons (cons 'domain-literal (substring str 1 (1- p)))
  111.           (substring str p))
  112.       )))
  113.  
  114. (defun std11-analyze-comment (str)
  115.   (let ((p (std11-check-enclosure str ?\( ?\) t)))
  116.     (if p
  117.     (cons (cons 'comment (substring str 1 (1- p)))
  118.           (substring str p))
  119.       )))
  120.  
  121. (defun std11-lexical-analyze (str)
  122.   (let (dest ret)
  123.     (while (not (string-equal str ""))
  124.       (setq ret
  125.         (or (std11-analyze-quoted-string str)
  126.         (std11-analyze-domain-literal str)
  127.         (std11-analyze-comment str)
  128.         (std11-analyze-spaces str)
  129.         (std11-analyze-special str)
  130.         (std11-analyze-atom str)
  131.         '((error) . "")
  132.         ))
  133.       (setq dest (cons (car ret) dest))
  134.       (setq str (cdr ret))
  135.       )
  136.     (nreverse dest)
  137.     ))
  138.  
  139.  
  140. ;;; @ parser
  141. ;;;
  142.  
  143. (defun std11-ignored-token-p (token)
  144.   (let ((type (car token)))
  145.     (or (eq type 'spaces)(eq type 'comment))
  146.     ))
  147.  
  148. (defun std11-parse-token (lal)
  149.   (let (token itl)
  150.     (while (and lal
  151.         (progn
  152.           (setq token (car lal))
  153.           (std11-ignored-token-p token)
  154.           ))
  155.       (setq lal (cdr lal))
  156.       (setq itl (cons token itl))
  157.       )
  158.     (cons (nreverse (cons token itl))
  159.       (cdr lal))
  160.     ))
  161.  
  162. (defun std11-parse-ascii-token (lal)
  163.   (let (token itl parsed token-value)
  164.     (while (and lal
  165.         (setq token (car lal))
  166.         (or (std11-ignored-token-p token)
  167.             (if (and (setq token-value (cdr token))
  168.                  (find-non-ascii-charset-string token-value)
  169.                  )
  170.             (setq token nil)
  171.               )))
  172.       (setq lal (cdr lal))
  173.       (setq itl (cons token itl))
  174.       )
  175.     (if (and token
  176.          (setq parsed (nreverse (cons token itl)))
  177.          )
  178.     (cons parsed (cdr lal))
  179.       )))
  180.  
  181. (defun std11-parse-token-or-comment (lal)
  182.   (let (token itl)
  183.     (while (and lal
  184.         (progn
  185.           (setq token (car lal))
  186.           (eq (car token) 'spaces)
  187.           ))
  188.       (setq lal (cdr lal))
  189.       (setq itl (cons token itl))
  190.       )
  191.     (cons (nreverse (cons token itl))
  192.       (cdr lal))
  193.     ))
  194.  
  195. (defun std11-parse-word (lal)
  196.   (let ((ret (std11-parse-ascii-token lal)))
  197.     (if ret
  198.     (let ((elt (car ret))
  199.           (rest (cdr ret))
  200.           )
  201.       (if (or (assq 'atom elt)
  202.           (assq 'quoted-string elt))
  203.           (cons (cons 'word elt) rest)
  204.         )))))
  205.  
  206. (defun std11-parse-word-or-comment (lal)
  207.   (let ((ret (std11-parse-token-or-comment lal)))
  208.     (if ret
  209.     (let ((elt (car ret))
  210.           (rest (cdr ret))
  211.           )
  212.       (cond ((or (assq 'atom elt)
  213.              (assq 'quoted-string elt))
  214.          (cons (cons 'word elt) rest)
  215.          )
  216.         ((assq 'comment elt)
  217.          (cons (cons 'comment-word elt) rest)
  218.          ))
  219.       ))))
  220.  
  221. (defun std11-parse-phrase (lal)
  222.   (let (ret phrase)
  223.     (while (setq ret (std11-parse-word-or-comment lal))
  224.       (setq phrase (append phrase (cdr (car ret))))
  225.       (setq lal (cdr ret))
  226.       )
  227.     (if phrase
  228.     (cons (cons 'phrase phrase) lal)
  229.       )))
  230.  
  231. (defun std11-parse-local-part (lal)
  232.   (let ((ret (std11-parse-word lal)))
  233.     (if ret
  234.     (let ((local-part (cdr (car ret))) dot)
  235.       (setq lal (cdr ret))
  236.       (while (and (setq ret (std11-parse-ascii-token lal))
  237.               (setq dot (car ret))
  238.               (string-equal (cdr (assq 'specials dot)) ".")
  239.               (setq ret (std11-parse-word (cdr ret)))
  240.               (setq local-part
  241.                 (append local-part dot (cdr (car ret)))
  242.                 )
  243.               (setq lal (cdr ret))
  244.               ))
  245.       (cons (cons 'local-part local-part) lal)
  246.       ))))
  247.  
  248. (defun std11-parse-sub-domain (lal)
  249.   (let ((ret (std11-parse-ascii-token lal)))
  250.     (if ret
  251.     (let ((sub-domain (car ret)))
  252.       (if (or (assq 'atom sub-domain)
  253.           (assq 'domain-literal sub-domain)
  254.           )
  255.           (cons (cons 'sub-domain sub-domain)
  256.             (cdr ret)
  257.             )
  258.         )))))
  259.  
  260. (defun std11-parse-domain (lal)
  261.   (let ((ret (std11-parse-sub-domain lal)))
  262.     (if ret
  263.     (let ((domain (cdr (car ret))) dot)
  264.       (setq lal (cdr ret))
  265.       (while (and (setq ret (std11-parse-ascii-token lal))
  266.               (setq dot (car ret))
  267.               (string-equal (cdr (assq 'specials dot)) ".")
  268.               (setq ret (std11-parse-sub-domain (cdr ret)))
  269.               (setq domain
  270.                 (append domain dot (cdr (car ret)))
  271.                 )
  272.               (setq lal (cdr ret))
  273.               ))
  274.       (cons (cons 'domain domain) lal)
  275.       ))))
  276.  
  277. (defun std11-parse-at-domain (lal)
  278.   (let ((ret (std11-parse-ascii-token lal)) at-sign)
  279.     (if (and ret
  280.          (setq at-sign (car ret))
  281.          (string-equal (cdr (assq 'specials at-sign)) "@")
  282.          (setq ret (std11-parse-domain (cdr ret)))
  283.          )
  284.     (cons (cons 'at-domain (append at-sign (cdr (car ret))))
  285.           (cdr ret))
  286.       )))
  287.  
  288. (defun std11-parse-addr-spec (lal)
  289.   (let ((ret (std11-parse-local-part lal))
  290.     addr)
  291.     (if (and ret
  292.          (prog1
  293.          (setq addr (cdr (car ret)))
  294.            (setq lal (cdr ret))
  295.            (and (setq ret (std11-parse-at-domain lal))
  296.             (setq addr (append addr (cdr (car ret))))
  297.             (setq lal (cdr ret))
  298.             )))
  299.     (cons (cons 'addr-spec addr) lal)
  300.       )))
  301.  
  302. (defun std11-parse-route (lal)
  303.   (let ((ret (std11-parse-at-domain lal))
  304.     route comma colon)
  305.     (if (and ret
  306.          (progn
  307.            (setq route (cdr (car ret)))
  308.            (setq lal (cdr ret))
  309.            (while (and (setq ret (std11-parse-ascii-token lal))
  310.                (setq comma (car ret))
  311.                (string-equal (cdr (assq 'specials comma)) ",")
  312.                (setq ret (std11-parse-at-domain (cdr ret)))
  313.                )
  314.          (setq route (append route comma (cdr (car ret))))
  315.          (setq lal (cdr ret))
  316.          )
  317.            (and (setq ret (std11-parse-ascii-token lal))
  318.             (setq colon (car ret))
  319.             (string-equal (cdr (assq 'specials colon)) ":")
  320.             (setq route (append route colon))
  321.             )
  322.            ))
  323.     (cons (cons 'route route)
  324.           (cdr ret)
  325.           )
  326.       )))
  327.  
  328. (defun std11-parse-route-addr (lal)
  329.   (let ((ret (std11-parse-ascii-token lal))
  330.     < route addr-spec >)
  331.     (if (and ret
  332.          (setq < (car ret))
  333.          (string-equal (cdr (assq 'specials <)) "<")
  334.          (setq lal (cdr ret))
  335.          (progn (and (setq ret (std11-parse-route lal))
  336.              (setq route (cdr (car ret)))
  337.              (setq lal (cdr ret))
  338.              )
  339.             (setq ret (std11-parse-addr-spec lal))
  340.             )
  341.          (setq addr-spec (cdr (car ret)))
  342.          (setq lal (cdr ret))
  343.          (setq ret (std11-parse-ascii-token lal))
  344.          (setq > (car ret))
  345.          (string-equal (cdr (assq 'specials >)) ">")
  346.          )
  347.     (cons (cons 'route-addr (append route addr-spec))
  348.           (cdr ret)
  349.           )
  350.       )))
  351.  
  352. (defun std11-parse-phrase-route-addr (lal)
  353.   (let ((ret (std11-parse-phrase lal)) phrase)
  354.     (if ret
  355.     (progn
  356.       (setq phrase (cdr (car ret)))
  357.       (setq lal (cdr ret))
  358.       ))
  359.     (if (setq ret (std11-parse-route-addr lal))
  360.     (cons (list 'phrase-route-addr
  361.             phrase
  362.             (cdr (car ret)))
  363.           (cdr ret))
  364.       )))
  365.  
  366. (defun std11-parse-mailbox (lal)
  367.   (let ((ret (or (std11-parse-phrase-route-addr lal)
  368.          (std11-parse-addr-spec lal)))
  369.     mbox comment)
  370.     (if (and ret
  371.          (prog1
  372.          (setq mbox (car ret))
  373.            (setq lal (cdr ret))
  374.            (if (and (setq ret (std11-parse-token-or-comment lal))
  375.             (setq comment (cdr (assq 'comment (car ret))))
  376.             )
  377.            (setq lal (cdr ret))
  378.          )))
  379.     (cons (list 'mailbox mbox comment)
  380.           lal)
  381.       )))
  382.  
  383. (defun std11-parse-group (lal)
  384.   (let ((ret (std11-parse-phrase lal))
  385.     phrase colon comma mbox semicolon)
  386.     (if (and ret
  387.          (setq phrase (cdr (car ret)))
  388.          (setq lal (cdr ret))
  389.          (setq ret (std11-parse-ascii-token lal))
  390.          (setq colon (car ret))
  391.          (string-equal (cdr (assq 'specials colon)) ":")
  392.          (setq lal (cdr ret))
  393.          (progn
  394.            (and (setq ret (std11-parse-mailbox lal))
  395.             (setq mbox (list (car ret)))
  396.             (setq lal (cdr ret))
  397.             (progn
  398.               (while (and (setq ret (std11-parse-ascii-token lal))
  399.                   (setq comma (car ret))
  400.                   (string-equal
  401.                    (cdr (assq 'specials comma)) ",")
  402.                   (setq lal (cdr ret))
  403.                   (setq ret (std11-parse-mailbox lal))
  404.                   (setq mbox (cons (car ret) mbox))
  405.                   (setq lal (cdr ret))
  406.                   )
  407.             )))
  408.            (and (setq ret (std11-parse-ascii-token lal))
  409.             (setq semicolon (car ret))
  410.             (string-equal (cdr (assq 'specials semicolon)) ";")
  411.             )))
  412.     (cons (list 'group phrase (nreverse mbox))
  413.           (cdr ret)
  414.           )
  415.       )))
  416.  
  417. (defun std11-parse-address (lal)
  418.   (or (std11-parse-group lal)
  419.       (std11-parse-mailbox lal)
  420.       ))
  421.  
  422. (defun std11-parse-addresses (lal)
  423.   (let ((ret (std11-parse-address lal)))
  424.     (if ret
  425.     (let ((dest (list (car ret))))
  426.       (setq lal (cdr ret))
  427.       (while (and (setq ret (std11-parse-ascii-token lal))
  428.               (string-equal (cdr (assq 'specials (car ret))) ",")
  429.               (setq ret (std11-parse-address (cdr ret)))
  430.               )
  431.         (setq dest (cons (car ret) dest))
  432.         (setq lal (cdr ret))
  433.         )
  434.       (nreverse dest)
  435.       ))))
  436.  
  437.  
  438. ;;; @ end
  439. ;;;
  440.  
  441. (provide 'std11-parse)
  442.  
  443. ;;; std11-parse.el ends here
  444.